home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 1 / Cream of the Crop 1.iso / PROGRAM / VIS082S.ARJ / FARGO.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-07  |  16KB  |  541 lines
  1. Program Wells_Fargo;
  2.  
  3. Uses Dos,CRT,ExecSwap,FastTTT5,WinTTT5,MenuTTT5,PullTTT5,ReadTTT5;
  4.  
  5. Type WFRecord=Record
  6.       Description   :String[40];
  7.       Path          :String[35];
  8.       ProgramName   :String[12];
  9.       Password      :String[20];
  10.       UseEMS        :Boolean;
  11.      End;
  12.  
  13. Const PassChar    = #15;
  14.     CursorRight = #205;
  15.     CursorLeft  = #203;
  16.     CursorDown  = #208;
  17.     CursorUp    = #200;
  18.     EnterKey    = #13;
  19.     EscKey      = #27;
  20.     EndKey      = #207;
  21.     HomeKey     = #199;
  22.     DelKey      = #211;
  23.     Backspace   = #8;
  24.     InsKey      = #210;
  25.     Zap         = #160;      {Alt D to delete the field}
  26.     MinInt              = -32768;
  27.     MaxLongInt:longint  =  2147483647;
  28.     MinLongInt:longint  = -2147483647;
  29.     MaxWord             =  65535;
  30.     MinWord             =  0;
  31.  
  32. Var wffile:file of WFRecord;
  33.     num:integer;
  34.     r,ar:WFRecord;
  35.     Main_Choice,Choice,Error:integer;
  36.     X,Y,ScanTop,ScanBot:byte;
  37.     M1,MM:Menu_record;
  38.     Ch:char;
  39.     Done:Boolean;
  40.     Cursor_X,
  41.     Cursor_Y:byte;
  42.     temp:String;
  43.  
  44.   Procedure Clang;
  45.   begin
  46.    sound(1500);
  47.    delay(50);
  48.    nosound;
  49.   end;
  50.  
  51. Procedure Read_Line(X,Y,L,F,B,Format:byte; Text:String);
  52.  
  53. {
  54. X is X coord of first character in field
  55. Y is Y coord of field
  56. L is the maximum length of the input field
  57. F is the foreground color
  58. B is the background color
  59. Fornat Codes:      1   Any String
  60.                    2   Force Upper String
  61.                    3   Yes/No
  62.                    4   Alphabetics only
  63.                    5   Integer
  64.                    6   LongInteger
  65.                    7   Real
  66.                    8   Word
  67.                    (*   Maybe
  68.                    9   Date    (MM/DD/YY)
  69.                    10  Date    (DD/MM/YY)
  70.                    *)
  71.                    11  Echo a Password
  72. Text is a string updated with the string equivalent of user input
  73. }
  74. var
  75.     TempText : string;
  76.     CursorPos : byte;
  77.     InsertMode,
  78.     Password,
  79.     Alldone : boolean;
  80.     FirstCharPress: boolean;
  81.     Ch : char;
  82.  
  83.     Procedure Check_Parameters;
  84.     begin
  85.         TempText := Text;
  86.         If length(TempText) > L then
  87.            Delete(Temptext,L+1,length(TempText)-L);
  88.         If not X in [1..80] then
  89.            X := 1;
  90.         If X + L - 1 > 80 then X := 81 - L;
  91.         If not Y in [1..25] then
  92.            Y := 1;
  93.         If RTTT.BegCursor then
  94.            CursorPos := 1
  95.         else
  96.         begin
  97.             If length(TempText) < L then
  98.                CursorPos := length(TempText) + 1
  99.             else
  100.                CursorPos := length(TempText);
  101.         end;
  102.         InsertMode  := RTTT.Insert;
  103.         Alldone := False;
  104.         If Format = 11 then
  105.         begin
  106.             Password := true;
  107.             Format := 1;
  108.         end
  109.         else
  110.            Password := false;
  111.     end;  {sub Proc Check_Parameters}
  112.  
  113.     Function FillWhiteSpace(Str:string):string;
  114.     var I : integer;
  115.     begin
  116.         If Password then
  117.            Str := replicate(length(Str),PassChar);
  118.         while length(Str) < L do
  119.               Str := Str + RTTT.WhiteSpace;
  120.         FillWhiteSpace := Str;
  121.     end; {sub Func FillWhiteSpace}
  122.  
  123.     Procedure MoveTheCursor;
  124.     begin
  125.         GotoXY(X+CursorPos-1,Y);
  126.     end;  {sub Proc MoveTheCursor}
  127.  
  128.     Procedure Write_String;
  129.     begin
  130.         Fastwrite(X,Y,attr(F,B),FillWhiteSpace(TempText));
  131.         MoveTheCursor;
  132.     end;
  133.  
  134.     Procedure Erase_Field;
  135.     begin
  136.         TempText := '';
  137.         CursorPos := 1;
  138.         Write_String;
  139.     end;
  140.  
  141.     Procedure Char_Backspace;
  142.     begin
  143.         If CursorPos > 1 then
  144.         begin
  145.             CursorPos := Pred(CursorPos);
  146.             Delete(TempText,CursorPos,1);
  147.             Write_String;
  148.        end;
  149.     end;   {sub Proc Char_Backspace}
  150.  
  151.     Procedure Char_Del;
  152.     begin
  153.         If CursorPos <= length(TempText) then
  154.         begin
  155.             Delete(TempText,CursorPos,1);
  156.             Write_String;
  157.         end;
  158.     end;   {sub Proc Char_Del}
  159.  
  160.     Procedure Add_Char(Ch:char);
  161.     begin
  162.         If InsertMode then
  163.         begin
  164.             If length(TempText) < L then
  165.             begin
  166.                 Insert(Ch,TempText,CursorPos);
  167.                 If CursorPos < L then
  168.                    CursorPos := Succ(CursorPos);
  169.            end;
  170.         end
  171.         else {not insertmode}
  172.         begin
  173.             Delete(TempText,CursorPos,1);
  174.             Insert(Ch,TempText,CursorPos);
  175.             If CursorPos < L then
  176.                CursorPos := Succ(CursorPos);
  177.         end;   {if insert}
  178.         Write_String;
  179.     end;   {sub proc Add_Char}
  180.  
  181.  
  182. begin                  {main Procedure Read_Line}
  183.     Check_Parameters;
  184.     R_Null := false;
  185. (*    FindCursor(Cursor_X,Cursor_Y,ScanTop,ScanBot); *)
  186.     If RTTT.Insert then
  187.        HalfCursor
  188.     else
  189.        OnCursor;
  190.     Write_String;
  191.     FirstCharPress := true;
  192.     Repeat
  193.          Ch := ReadKey; (* Getkey; *)
  194.          If Format in [2,3] then
  195.             Ch := upcase(Ch);
  196.          If Ch in RTTT.End_Chars then
  197.          begin
  198.             AllDone := True;
  199.             If Ch <> #027 then Text := TempText;
  200.          end
  201.          else
  202.          Case Ch of
  203.          #131,              {mouseright}
  204.          CursorRight   :  begin
  205.                               If (CursorPos < L)
  206.                               and (CursorPos <= length(TempText)) then
  207.                               begin
  208.                                   CursorPos := Succ(CursorPos);
  209.                                   MoveTheCursor;
  210.                               end;
  211.                           end;
  212.          #130,               {mouseleft}
  213.          CursorLeft    :  begin
  214.                               If CursorPos > 1 then
  215.                               begin
  216.                                   CursorPos := Pred(CursorPos);
  217.                                   MoveTheCursor;
  218.                               end;
  219.                           end;
  220.          HomeKey       :  begin
  221.                               CursorPos := 1;
  222.                               MoveTheCursor;
  223.                           end;
  224.          EndKey        :  begin
  225.                               If CursorPos < L then
  226.                               If length(TempText) < L then
  227.                                   CursorPos := length(TempText) + 1
  228.                               else
  229.                                   CursorPos := L;
  230.                               MoveTheCursor;
  231.                           end;
  232.         InsKey        :  If Format <> 3 then   {don't allow insert on Y/N!}
  233.                          begin
  234.                              InsertMode := not InsertMode;
  235.                              If InsertMode then
  236.                                 HalfCursor
  237.                              else
  238.                                 OnCursor;
  239.                          end;
  240.         DelKey        :  Char_Del;
  241.         BackSpace     :  Char_Backspace;
  242.         Zap           :  Erase_Field;
  243.         #132,
  244.         EscKey        :  If RTTT.AllowEsc then
  245.                              Alldone := true;
  246.         #133,
  247.         EnterKey      :  begin
  248.                              Alldone := true;
  249.                              Text := TempText;
  250.                              temp:=TempText;
  251.                          end;
  252.        #33 .. #42,                                 {! to *}
  253.        #44,#47,                                    {, /}
  254.        #58 .. #64,                                 {: to @}
  255.        #91 .. #96,                                 {[ to '}
  256.        #123 .. #126   :  If (Format in [1,2]) then {{ to ~}
  257.                          begin
  258.                              If FirstCharPress and RTTT.EraseDefault then
  259.                                 Erase_Field;
  260.                              Add_Char(Ch);
  261.                          end
  262.                          else
  263.                              Clang;
  264.        #43, #45       : If (Format in [1,2])       { + - }
  265.                         or ( (CursorPos=1) and (Format in [5,6,7])) then
  266.                         begin
  267.                             If FirstCharPress and RTTT.EraseDefault then
  268.                                 Erase_Field;
  269.                             Add_Char(Ch);
  270.                         end
  271.                         else
  272.                            Clang;
  273.        #46            : If (Format in [1,2])       {.}
  274.                         or ( (Pos('.',TempText)=0) and (Format = 7)) then
  275.                         begin
  276.                             If FirstCharPress and RTTT.EraseDefault then
  277.                                 Erase_Field;
  278.                             Add_Char(Ch);
  279.                         end
  280.                         else
  281.                            Clang;
  282.        #48..#57       : If (Format in [1..2,5..8]) then {0 to 9}
  283.                         begin
  284.                             If FirstCharPress and RTTT.EraseDefault then
  285.                                 Erase_Field;
  286.                             Add_Char(Ch);
  287.                         end
  288.                         else
  289.                            Clang;
  290.        #32,                                              {space}
  291.        #65..#77,                                         {A to M}
  292.        #79..#88,                                         {O to X}
  293.        #90,                                              {Z}
  294.        #97..#122      : If (Format in [1,2,4]) then      {a to z}
  295.                         begin
  296.                             If FirstCharPress and RTTT.EraseDefault then
  297.                                 Erase_Field;
  298.                             Add_Char(Ch);
  299.                         end
  300.                         else
  301.                            Clang;
  302.        #78,#89        : If (Format in [1..4]) then        {N Y}
  303.                         begin
  304.                             Add_Char(Ch);
  305.                             If Format = 3 then
  306.                             begin
  307.                                 Alldone := true;
  308.                                 Text := TempText;
  309.                             end;
  310.                         end
  311.                         else
  312.                            Clang;
  313.       #128,#129       :;    {absorb stray mouse movement to avoid Clang'n}
  314.       else Clang;
  315.       end; {case}
  316.       FirstCharPress := false;
  317.       Until Alldone;
  318.       R_Char := Ch;
  319.       If  RTTT.RightJustify
  320.       and (Format > 4) then
  321.       begin
  322.           Fastwrite(X,Y,attr(F,B),replicate(L,RTTT.Whitespace));
  323.           Fastwrite(X+L-Length(TempText),Y,attr(F,B),Text);
  324.       end
  325.       else
  326.         Fastwrite(X,Y,attr(F,B),FillWhiteSpace(Text));
  327.       GotoXY(Cursor_X,Cursor_Y);
  328.       SizeCursor(ScanTop,ScanBot);
  329. end;
  330.  
  331. function exist (n:string):boolean;
  332. var f:file;
  333.     i:integer;
  334. begin
  335.   assign (f,n);
  336.   reset (f);
  337.   i:=ioresult;
  338.   exist:=i=0;
  339.   close (f);
  340.   i:=ioresult
  341. end;
  342.  
  343.  function numentry:integer;
  344.   begin
  345.     numentry:=filesize(WFfile)
  346.   end;
  347.  
  348.   procedure seekwffile (n:integer);
  349.   begin
  350.     seek (WFfile,n-1)
  351.   end;
  352.  
  353.   procedure openwffile;
  354.   var n:integer;
  355.   begin
  356.     n:=ioresult;
  357.     assign (WFfile,'FARGO.DAT');
  358.     reset (WFfile);
  359.     if ioresult<>0 then begin
  360.       close (WFfile);
  361.       n:=ioresult;
  362.       rewrite (WFfile)
  363.     end
  364.   end;
  365.  
  366.   Procedure Grand_Opening;
  367.   Begin
  368.    FillScreen(1,1,80,25,white,blue,chr(176));
  369.    GrowFBox(25,10,55,17,yellow,blue,4);
  370.    WriteCenter(12,15,1,'Wells Fargo Quick Menus');
  371.    WriteCenter(13,15,1,'Written By: Josh Ham');
  372.    WriteCenter(14,15,1,'Requested By: Larry Ham');
  373.    WriteCenter(16,11,1,'Quick Menus (c)1991');
  374.    Delay(3000);
  375.   End;
  376.  
  377.   Procedure Entry_Box;
  378.   Begin
  379.    FillScreen(1,1,80,25,white,blue,char(176));
  380.    TextAttr:=1;
  381.    GrowFBox(15,5,65,20,blue,blue,4);
  382.    TextAttr:=8;
  383.    For x:=17 to 66 Do Begin Gotoxy(x,21); Write(char(219)); End;
  384.    For y:=6 to 21 Do Begin Gotoxy(66,y); Write(char(219)+Char(219)); End;
  385.   End;
  386.  
  387.   Procedure EC;
  388.   Begin
  389.    Textbackground(7);
  390.    Textcolor(0);
  391.   End;
  392.  
  393.   Procedure EF;
  394.   Begin
  395.    Textbackground(1);
  396.    Textcolor(11);
  397.   End;
  398.  
  399.   Procedure Add_An_Entry;
  400.   var ch:Char;
  401.       a,b,c,d:string;
  402.   Begin
  403.    Entry_Box;
  404.    Textbackground(1);
  405.    TextColor(14);
  406.    Gotoxy(22,6);
  407.    Write('Wells Fargo Quick Menus - Add an Entry');
  408.    TextColor(9);
  409.    For x:=15 to 65 Do Begin gotoxy(x,7); Write(char(196)); End;
  410.    TextColor(11);
  411.    OpenWfFile;
  412.    num:=numentry;
  413.    Gotoxy(17,9);  Write('Enter Filename To Execute'); ec;
  414.    Gotoxy(17,10); Write('············'); ef;
  415.    Gotoxy(17,12); Write('Enter Full Path To The Above File'); ec;
  416.    Gotoxy(17,13); Write('····································'); ef;
  417.    Gotoxy(17,15); Write('Enter a Description Of This Entry'); ec;
  418.    gotoxy(17,16); Write('·········································'); ef;
  419.    gotoxy(17,18); Write('Enter a Password To Load This (Enter=None)'); ec;
  420.    gotoxy(17,19); Write('·····················');
  421.    clang;
  422.    r.programname:='';
  423.    Gotoxy(17,10);ReadLine(17,10,12,0,7,r.programname);
  424.    r.programname:=temp;
  425.    r.path:='';
  426.    gotoxy(17,13);ReadLine(17,13,35,0,7,r.path);
  427.    r.path:=temp;
  428.    r.description:='';
  429.    gotoxy(17,16);ReadLine(17,16,40,0,7,r.description);
  430.    r.description:=temp;
  431.    r.password:='';
  432.    gotoxy(17,19);ReadLine(17,19,20,0,7,r.password);
  433.    r.password:=temp;
  434.    GrowFBox(25,1,53,3,lightblue,blue,4);
  435.    Clang; ef;
  436.    textcolor(15);
  437.    Gotoxy(27,2); Write('Save This To Disk? [Y/N]');
  438.    Repeat
  439.    Ch:=ReadKey;
  440.    Until (ch='Y') or (ch='y') or (ch='N') or (ch='n');
  441.    If (ch='Y') or (ch='y') Then Begin
  442.    if not exist ('FARGO.DAT') then rewrite (WFfile);
  443.    seekwffile(num+1);
  444.    write (WFfile,r);
  445.    End;
  446.    ef;
  447.    FillScreen(1,1,80,25,white,blue,chr(176));
  448.    Close(Wffile);
  449.    End;
  450.  
  451.    Procedure Edit_Entry;
  452.    var howmany:integer;
  453.    Begin
  454.     FillScreen(1,1,80,25,white,blue,chr(176));
  455.      GrowFBox(25,1,53,3,lightblue,blue,4);
  456.      Clang; ef;
  457.      textcolor(15);
  458.      OpenWffile;
  459.      howmany:=numentry;
  460.      Gotoxy(27,2); Write('Edit Which Entry? [1-',howmany,']:');
  461.      gotoxy(51,2); ReadLn(howmany);
  462.      seekwffile(howmany+1);
  463.      read(wffile,r);
  464.     FillScreen(30,5,75,15,blue,blue,chr(219)); ef;
  465.     GotoXy(42,6); Write('Wells Fargo Quick Menu Editor'); ec;
  466.     Gotoxy(32,8); Write('············');
  467.     Gotoxy(32,10); Write('····································');
  468.     gotoxy(32,12); Write('·········································');
  469.     gotoxy(32,14); Write('·····················');
  470.     gotoxy(32,8); Write(r.programname);
  471.     gotoxy(32,10);Write(r.path);
  472.     gotoxy(32,12);Write(r.description);
  473.     gotoxy(32,14);If r.password='' then Write ('N/A') Else write(r.password);
  474.     readln;
  475.     Close(WfFile);
  476.    End;
  477.  
  478.    Procedure Utilitys;
  479.    Begin
  480.     Menu_Set(M1);
  481.     With M1 do
  482.     begin
  483.         Heading1 := '- Wells Fargo Quick Menu Utilitys -';
  484.         Heading2 := 'Quick Menus (c)1991';
  485.         Topic[1] := '   Add a new entry';
  486.         Topic[2] := '   Edit an existing entry';
  487.         Topic[3] := '   Delete an existing entry ';
  488.         Topic[4] := '   Quit Utility Section';
  489.         TotalPicks := 4;
  490.         PicksPerLine := 1;
  491.         Addprefix := 0;
  492.         TopleftXY[1] := 0;
  493.         TopleftXY[2] := 8;
  494.         Boxtype := 5;
  495.         If ColorScreen then
  496.         begin
  497.             Colors[1] := white;
  498.             Colors[2] := blue;
  499.             Colors[3] := lightgray;
  500.             Colors[4] := red;
  501.             Colors[5] := lightgray;
  502.         end
  503.         else
  504.         begin
  505.             Colors[1] := white;
  506.             Colors[2] := black;
  507.             Colors[3] := black;
  508.             Colors[4] := lightgray;
  509.             Colors[5] := white;
  510.         end;
  511.         AllowEsc := false;
  512.         Margins := 5;
  513. end;  {with M1 do}
  514. end; {Define_Menu1}
  515.  
  516. Procedure Utility_Menu;
  517. Var Quit:Boolean;
  518. Begin
  519.     Quit:=False;
  520.     Findcursor(X,Y,ScanTop,ScanBot);
  521.     Main_Choice := 1;
  522.     Done:=False;
  523.     FillScreen(1,1,80,25,white,blue,chr(176));
  524.     repeat
  525.      Utilitys;
  526.      DisplayMenu(M1,false,Main_Choice,Error);
  527.      Case Main_Choice of
  528.      1:Add_An_Entry;
  529.      2:Edit_Entry;
  530.      3:Begin End;{Delete_An_Entry;}
  531.      4:Quit:=True;
  532.      end;
  533. until Quit;
  534. FillScreen(1,1,80,24,white,blue,chr(176));
  535. main_choice:=1;
  536. End;
  537.  
  538. Begin
  539. Grand_Opening;
  540. Utility_Menu;
  541. End.